Programming Languages Suite/ProgramD2.iso/Visual Database/Visual Foxpro 6.0 (Ent. Edition)/Vf6ent Extractor.EXE/GENMENU.PRG

Text File | 1998-05-26 | 74.2 KB | 2,537 lines

******************************************************************************
* GENMENU - Menu code generator.
*
* Copyright (c) 1990 - 1995 Microsoft Corp.
* 1 Microsoft Way
* Redmond, WA 98052
*
* Description:
* This program generates menu code which was designed in the
* FoxPro 3.0 MENU BUILDER.
*
* Modification History:
* December 13, 1990        JAC        Program Created
*
* Modified for FoxPro 2.5 by WJK
* Modified for FoxPro 3.0 by DTA
* Modified for FoxPro 5.0 by RB
*
******************************************************************************
* MS SourceSafe Keywords:
* $Workfile: GENMENU.PRG $
*   $Author: Dta $
*     $Date: 3/19/95 1:04a $
*  $Logfile: /Genmenu/GENMENU.PRG $
*  $Modtime: 3/19/95 1:04a $
* $Revision: 8 $
*
* NOTE: Revisions history kept at end of file.
******************************************************************************
******************************************************************************
*
* Declare Constants
*
******************************************************************************
* Move constants above executable code [Rev: 3][BEG]
#DEFINE c_DEBUG .F.  && Add debug mode [Rev: 4][ADD]
*
#DEFINE c_esc    CHR(27)
#DEFINE c_null    CHR(0)
#DEFINE c_CRLF  CHR(13) + CHR(10)   && Carriage return + Line feed constant [Rev: 6][ADD]
#DEFINE c_aliaslen 255               && Support long file names [Rev: 7][MOD]
*
* Possible values of Objtype field in SCX database.
*
#DEFINE c_menu        1
#DEFINE c_submenu    2
#DEFINE c_item        3
#DEFINE c_shortcut    4
#DEFINE c_sdimenu    5
*
* Some of the values of Objcode field in SCX database.
*
#DEFINE    c_global         1
#DEFINE c_proc          80
#DEFINE c_maxsnippets   25
#DEFINE c_maxpads        25
#DEFINE c_pjx20flds        33
#DEFINE c_pjxflds        28   && Changed from 31 [Rev: 2][MOD]
#DEFINE c_mnxflds        23
#DEFINE c_20mnxflds        22
#DEFINE c_space         40   && Used by Thermfname
*
* Developer Information
*
#DEFINE c_authorlen        45
#DEFINE c_complen        45
#DEFINE c_addrlen        45
#DEFINE c_citylen        20
#DEFINE c_statlen        5
#DEFINE c_ziplen        10
#DEFINE c_countrylen    40
*
* Menu / pad location
*
#DEFINE c_replace        0
#DEFINE c_append        1
#DEFINE c_before        2
#DEFINE c_after            3
*
#DEFINE c_pathsep  "\"
*
* Add support for negotiate [Rev: 2][BEG]
#DEFINE c_neg_flag      "LOCATION"
#DEFINE c_neg_none            0
#DEFINE c_neg_left          1
#DEFINE c_neg_middle        2
#DEFINE c_neg_right         3
* Add support for negotiate [Rev: 2][BEG]
*
* Add localization support [Rev: 2][BEG]
#DEFINE c_hdr_author_LOC    "Author's Name"
#DEFINE c_hdr_company_LOC   "Company Name"
#DEFINE c_hdr_address_LOC   "Address"
#DEFINE c_hdr_city_LOC      "City"
#DEFINE c_hdr_state_LOC     "  "
#DEFINE c_hdr_zip_LOC       "Zip"
#DEFINE c_hdr_ctry_LOC      "Country"
#DEFINE c_hdr_copyright_LOC Copyright (C)
#DEFINE c_hdr_descript_LOC  Description:
#DEFINE c_hdr_string_LOC    This PROGRAM was automatically generated BY GENMENU.
#DEFINE c_shortcutdef_LOC  "FoxShortcutMenu"

*
#DEFINE c_snip_setup_LOC    " Setup Code"
#DEFINE c_snip_cleanup_LOC  " Cleanup Code & Procedures"
#DEFINE c_snip_init_LOC     " Initializing Code"
#DEFINE c_snip_menu_LOC     " Menu Definition"

#DEFINE c_dlgface_mac_LOC       "Geneva"
#DEFINE c_dlgface_nonmac_LOC    "MS Sans Serif"
#DEFINE c_dlgstyle_mac_LOC       ""
#DEFINE c_dlgstyle_nonmac_LOC     ""

*
* Genmenu error types
*
#DEFINE c_error_1        "Minor"
#DEFINE c_error_2        "Serious"
#DEFINE c_error_3        "Fatal"
#DEFINE c_error_1Icon   64   &&   Error icons [Rev: 6][ADD]
#DEFINE c_error_2Icon   48   &&   Error icons [Rev: 6][ADD]
#DEFINE c_error_3Icon   16   &&   Error icons [Rev: 6][ADD]
#DEFINE c_err_invnumparm_LOC     "Invalid number of parameters passed to the generator."
#DEFINE c_err_badgendate_LOC     "Generator out of date."
#DEFINE c_err_badrechead_LOC     "Missing header record in "
#DEFINE c_err_nocloseapp_LOC     "Unable to Close the Application File."
#DEFINE c_err_badmnxpre_LOC      "Menu "
#DEFINE c_err_badmnxpost_LOC     " is invalid"
#DEFINE c_err_nofileopen_LOC     "Cannot open file "
#DEFINE c_err_badnegoval_LOC     "Invalid negotiate value in field "
#DEFINE c_err_title_LOC          "Genmenu Error"
#DEFINE c_err_lineno_LOC         "Line Number: "
#DEFINE c_err_presskey_LOC       "Press any key to cleanup and exit..."
#DEFINE c_err_noopenerr_LOC      ".ERR could not be opened..."
#DEFINE c_err_toomanymemvars_LOC "Too many memvars - GENMENU will terminate..."    && ERROR 22 [Rev: 4][ADD]
#DEFINE c_err_nobangallowed_LOC  "Menu file name cannot contain the character " + [" ! "]   && ! in menu [Rev: 6][ADD]
*
#DEFINE c_msg_gencomplete_LOC    "Generation Complete"
#DEFINE c_msg_genmenudefs_LOC    "Generating menu definitions..."
#DEFINE c_msg_genpopdefs_LOC     "Generating popup definitions..."
#DEFINE c_msg_genprocs_LOC       "Generating procedures..."
#DEFINE c_msg_gensetup_LOC       "Generating Menu Setup Code..."
#DEFINE c_msg_gencleanup_LOC     "Generating Menu Cleanup Code..."
#DEFINE c_msg_genstopped_LOC     "Generation process stopped."
#DEFINE c_msg_genmenucode_LOC    "Generating Menu Code..."
*
#DEFINE c_sdierrdisplay_loc        "[This menu can only be called from a Top-Level form. "+;
                                "Ensure that your form's ShowWindow property is set to 2. "+;
                                "Read the header section of the menu's MPR file for more details.]"
*
#DEFINE c_ui_whereis_LOC         WHERE is
* Add localization support [Rev: 2][END]
*
#DEFINE c_key_padhotkey_LOC      "ALT+"   && Add support for intelligent Pad hotkeys. [Rev: 7][ADD]
* Move constants above executable code [Rev: 3][END]
******************************************************************************
*
* Main program
*
******************************************************************************
PARAMETER m.projdbf, m.recno
PRIVATE ALL
*
* Setup initial environment for GENMENU
*
IF SET("TALK") = "ON"
   SET TALK OFF
   m.talkstate = "ON"
ELSE
   m.talkstate = "OFF"
ENDIF
m.coveragefile = SET("COVERAGE")
m.oldtextmerge = SET("TEXTMERGE")
SET COVERAGE TO
m.escape = SET("ESCAPE")
IF NOT c_DEBUG   && Add debug mode [Rev: 4][ADD]
   SET ESCAPE OFF
ENDIF
m.trbetween = SET("TRBET")
IF NOT c_DEBUG   && Add debug mode [Rev: 4][ADD]
   SET TRBET OFF
ENDIF
m.comp = SET("COMPATIBLE")
SET COMPATIBLE OFF
mdevice = SET("DEVICE")
SET DEVICE TO SCREEN
m.alternate = SET("ALTE")
SET ALTERNATE OFF
******************************************************************************
*
* Declare Variables
*
******************************************************************************
STORE "" TO m.cursor, m.consol, m.bell, m.onerror, m.fields, mfieldsto, ;
   m.exact, m.print, m.fixed, m.delimiters, m.mpoint, m.mcollate, m.mmacdesk, m.mcpdialog
STORE 0 TO m.deci, m.memowidth
*
* Fonts for thermometer bar / dialogs
*
* Change fonts to memvars [Rev: 4][BEG]
* Translate the filename into Mac native format
IF _MAC
   m.g_dlgface    = c_dlgface_mac_LOC
   m.g_dlgsize    = 10.000
   m.g_dlgstyle    = c_dlgstyle_mac_LOC
   m.g_pathsep    = ":"
ELSE
   m.g_dlgface    = c_dlgface_nonmac_LOC
   m.g_dlgsize    = 8.000
   m.g_dlgstyle    = c_dlgstyle_nonmac_LOC
   m.g_pathsep    = "\"
ENDIF
m.g_error      = .F.
m.g_errlog     = ""
m.g_homedir    = ""
m.g_location   = 0
m.g_menucolor  = 0
m.g_menumark   = ""
m.g_nohandle   = .T.
m.g_nsnippets  = 0
m.g_outfile    = ""
m.g_padloca    = ""
m.g_projalias  = ""
m.g_projdbf    = m.projdbf
m.g_projpath   = ""
m.g_status     = 0
m.g_snippcnt   = 0
m.g_thermwidth = 0
m.g_workarea   = 0
m.g_graphic    = .F.
m.g_20mnx       = .F.
m.g_shortcut   = .F.
m.g_inform     = .F.
m.g_shortcutname = ""
m.g_prepopup = .F.
*
* Add localization support [Rev: 2][BEG]
m.g_devauthor  = PADR( c_hdr_author_LOC ,45," ")
m.g_devcompany = PADR( c_hdr_company_LOC ,45, " ")
m.g_devaddress = PADR( c_hdr_address_LOC ,45," ")
m.g_devcity    = PADR( c_hdr_city_LOC ,20," ")
m.g_devstate   = c_hdr_state_LOC
m.g_devzip     = PADR( c_hdr_zip_LOC ,10," ")
m.g_devctry    = PADR( c_hdr_ctry_LOC ,40," ")
* Add localization support [Rev: 2][END]
*
m.g_boxstrg = ['─','─','│','│','┌','┐','└','┘','─','─','│','│','┌','┐','└','┘']
*
STORE "" TO m.g_corn1, m.g_corn2, m.g_corn3, m.g_corn4, m.g_corn5, ;
   m.g_corn6, m.g_verti2
STORE "*" TO  m.g_horiz, m.g_verti1
*
*
* Array Declarations
*
* g_mnxfile [1] - Normalized path + name
* g_mnxfile [2] - Basename
* g_mnxfile [3] - Opened originally?
* g_mnxfile [4] - Alias
*
DIMENSION g_mnxfile[4]
g_mnxfile[1] = ""
g_mnxfile[2] = ""
g_mnxfile[3] = .F.
g_mnxfile[4] = ""
*
* g_pads - names of generated menu pads
*
DIMENSION g_pads(c_maxpads)
*
* g_snippets [*,1] - generated snippet procedure name
* g_snippets [*,2] - recno()
*
DIMENSION g_snippets (c_maxsnippets,2)
g_snippets = ""

DIMENSION g_aPops(1)
g_aPops=""

IF AT("WINDOWS", UPPER(VERSION())) <> 0 OR ;
      AT("MAC", UPPER(VERSION())) <> 0
   m.g_graphic = .T.
ELSE
   m.g_graphic = .F.
ENDIF
*
* Main program
*
m.onerror = ON("ERROR")
ON ERROR DO errorhandler WITH MESSAGE(), LINENO(), c_error_3
*
IF PARAMETERS()=2
   DO setup
   IF validparams()
      ON ESCAPE DO eschandler
      SET ESCAPE ON
      DO refreshprefs
      DO BUILD
   ENDIF
   DO cleanup
ELSE
   DO errorhandler WITH c_err_invnumparm_LOC, LINENO(),c_error_3  && Localization support [Rev: 2][MOD]
ENDIF
ON ERROR &onerror
*
RETURN m.g_status


******************************************************************************
*
* Setup, Cleanup, Validparams, and Refreshprefs of Main Program
*
******************************************************************************
*
* STARTUP - Create program's environment.
*
* Description:
* Save the user's environment so that we can set it back when
* we are done, then issue various SET commands. The only state
* we cannot conveniently save is SET TALK, because storing the
* state involves an assignment statement, and assignments
* generate unwanted output if TALK is set ON.
*
* Side Effects:
* Creates a temporary file which is deleted in the Cleanup
* procedure executed at the end of MENUGEN.
*
FUNCTION setup
CLEAR PROGRAM
CLEAR GETS
m.g_workarea = SELECT()
m.delimiters = SET('TEXTMERGE',1)
SET TEXTMERGE DELIMITERS TO
SET UDFPARMS TO VALUE
m.mfieldsto = SET("FIELDS",1)
m.fields = SET("FIELDS")
SET FIELDS TO
SET FIELDS OFF
m.bell = SET("BELL")
SET BELL OFF
m.consol = SET("CONSOLE")
SET CONSOLE OFF
m.cursor = SET("CURSOR")
SET CURSOR OFF
m.deci = SET("DECIMALS")
SET DECIMALS TO 0
mdevice = SET("DEVICE")
SET DEVICE TO SCREEN
m.memowidth = SET("MEMOWIDTH")
SET MEMOWIDTH TO 256
m.exact = SET("EXACT")
SET EXACT ON
m.print = SET("PRINT")
SET PRINT OFF
m.fixed = SET("FIXED")
SET FIXED ON
mpoint = SET("POINT")
SET POINT TO "."
mcollate = SET("COLLATE")
SET COLLATE TO "machine"
mcpdialog = SET("CPDIALOG")
SET CPDIALOG OFF

#IF "MAC" $ UPPER(VERSION(1))
IF _MAC
   m.mmacdesk = SET("MACDESKTOP")
   SET MACDESKTOP ON
ENDIF
#ENDIF

*
* CLEANUP - restore environment to pre-execution state.
*
* Description:
* Close all databases opened in the course of the execution of MENUGEN.
* Restore the environment to the pre-execution of MENUGEN.  Delete
* the VIEW file since there is no further use for it.
*
* Side Effects:
* Closes databases.
* Deletes the temporary view file.
*
FUNCTION cleanup
PRIVATE m.delilen, m.ldelimi, m.rdelimi
IF EMPTY(m.g_projalias)
   RETURN
ENDIF
SELECT (m.g_projalias)
USE
IF NOT EMPTY(g_mnxfile[3])
   IF USED(g_mnxfile[4])
      SELECT (g_mnxfile[4])
      USE
   ENDIF
ENDIF
SELECT (m.g_workarea)
m.delilen = LEN(m.delimiters)
m.ldelimi = SUBSTR(m.delimiters,1,;
   IIF(MOD(m.delilen,2)=0,m.delilen/2,CEILING(m.delilen/2)))
m.rdelimi = SUBSTR(m.delimiters,;
   IIF(MOD(m.delilen,2)=0,m.delilen/2+1,CEILING(m.delilen/2)+1))
SET TEXTMERGE DELIMITERS TO m.ldelimi, m.rdelimi
IF (LEN(mfieldsto) > 2048)
   SET FIELDS TO
ELSE
   SET FIELDS TO &mfieldsto
ENDIF
IF m.fields = "ON"
   SET FIELDS ON
ELSE
   SET FIELDS OFF
ENDIF
IF m.bell = "ON"
   SET BELL ON
ENDIF
IF m.cursor = "ON"
   SET CURSOR ON
ELSE
   SET CURSOR OFF
ENDIF
IF m.consol = "ON"
   SET CONSOLE ON
ENDIF
IF m.escape = "ON"
   SET ESCAPE ON
ELSE
   SET ESCAPE OFF
ENDIF
IF m.print = "ON"
   SET PRINT ON
ENDIF
IF m.exact = "OFF"
   SET EXACT OFF
ENDIF
IF m.fixed = "OFF"
   SET FIXED OFF
ENDIF
SET DECIMALS TO m.deci
SET MEMOWIDTH TO m.memowidth
SET DEVICE TO &mdevice
IF m.trbetween = "ON"
   SET TRBET ON
ENDIF
IF m.comp = "ON"
   SET COMPATIBLE ON
ENDIF
IF m.talkstate = "ON"
   SET TALK ON
ENDIF
SET POINT TO "&mpoint"
SET COLLATE TO "&mcollate"
IF m.mcpdialog = "ON"
   SET CPDIALOG ON
ENDIF
IF m.alternate = "ON"
   SET ALTERNATE ON
ENDIF
SET MESSAGE TO
#IF "MAC" $ UPPER(VERSION(1))
IF _MAC
   SET MACDESKTOP &mmacdesk
ENDIF
#ENDIF

ON ERROR &onerror
IF !EMPTY(m.coveragefile)
    SET COVERAGE TO (m.coveragefile) ADDITIVE
ENDIF
SET TEXTMERGE TO
IF m.oldtextmerge = "ON"
    SET TEXTMERGE ON
ENDIF

*
* VALIDPARAMS - Validate generator parameters.
*
* Description:
* Attempt to open the project database.  If error encountered then
* on error routine takes over and issues 'CANCEL'.  The output file
* cannot be erased, name not known.
*
FUNCTION validparams
SELECT 0
m.g_projalias = IIF(USED("projdbf"),"P"+;
   SUBSTR(LOWER(SYS(3)),2,8),"projdbf")
USE (m.projdbf) ALIAS (m.g_projalias) AGAIN
IF versnum() > "2.5"
   SET NOCPTRANS TO devinfo, symbols, OBJECT
ENDIF
m.g_errlog = stripext(m.projdbf)
m.g_projpath = SUBSTR(m.projdbf,1,RAT("\",m.projdbf))
IF FCOUNT() <> c_pjxflds
   DO errorhandler WITH c_err_badgendate_LOC,LINENO(), c_error_2   && Localization support [Rev: 2][MOD]
   RETURN .F.
ENDIF
GOTO RECORD m.recno
m.g_outfile = ALLTRIM(SUBSTR(outfile,1,AT(c_null,outfile)-1))
m.g_outfile = FULLPATH(m.g_outfile, m.g_projpath)
IF _MAC AND RIGHT(m.g_outfile,1) = ":"
   m.g_outfile = m.g_outfile + justfname(SUBSTR(outfile,1,AT(c_null,outfile)-1))
ENDIF
g_mnxfile[1] = FULLPATH(ALLTRIM(name), m.g_projpath)
IF _MAC AND RIGHT(g_mnxfile[1],1) = ":"
   g_mnxfile[1] = g_mnxfile[1] + justfname(name)
ENDIF
g_mnxfile[2] = basename(g_mnxfile[1])
* No ! in menu name [Rev: 6][BEG]
IF "!" $ g_mnxfile[2]
   DO errorhandler WITH c_err_nobangallowed_LOC, LINENO(), c_error_3
ENDIF
* No ! in menu name [Rev: 6][END]


*
* REFRESHPREFS - Refresh comment style and developer preferences.
*
* Description:
* Get the newest preferences for documentation style and developer
* data from the project database.
*
FUNCTION refreshprefs
PRIVATE m.start, m.savrecno
m.savrecno = RECNO()
LOCATE FOR TYPE = "H"
IF NOT FOUND ()
   DO errorhandler WITH c_err_badrechead_LOC + m.g_projdbf,;
      LINENO(), c_error_2   && Localization support [Rev: 2][MOD]
   GOTO RECORD m.savrecno
   RETURN
ENDIF
m.g_homedir = ALLTRIM(SUBSTR(homedir,1,AT(c_null,homedir)-1))

IF (RIGHT(m.g_homedir, 1) == "\")
   m.g_homedir = m.g_homedir + "\"
ENDIF
m.start = 1
m.g_devauthor = subdevinfo(m.start,c_authorlen,m.g_devauthor)
m.start = m.start + c_authorlen + 1
m.g_devcompany = subdevinfo(m.start,c_complen,m.g_devcompany)
m.start = m.start + c_complen + 1
m.g_devaddress = subdevinfo(m.start,c_addrlen,m.g_devaddress)
m.start = m.start + c_addrlen + 1
m.g_devcity = subdevinfo(m.start,c_citylen,m.g_devcity)
m.start = m.start + c_citylen + 1
m.g_devstate = subdevinfo(m.start,c_statlen,m.g_devstate)
m.start = m.start + c_statlen + 1
m.g_devzip = subdevinfo(m.start,c_ziplen,m.g_devzip)
m.start = m.start + c_ziplen + 1
m.g_devctry = subdevinfo(m.start,c_countrylen,m.g_devctry)
IF cmntstyle = 0
   m.g_corn1 = chr(214)
   m.g_corn2 = chr(183)
   m.g_corn3 = chr(211)
   m.g_corn4 = chr(189)
   m.g_corn5 = chr(199)
   m.g_corn6 = chr(182)
   m.g_horiz = chr(196)
   m.g_verti1 = chr(186)
   m.g_verti2 = chr(186)
ENDIF
GOTO RECORD m.savrecno

*
* SUBDEVINFO - Substring the DEVINFO memo filed.
*
FUNCTION subdevinfo
PARAMETER m.start, m.stop, m.default
PRIVATE m.string
m.string = SUBSTR(devinfo, m.start, m.stop+1)
m.string = SUBSTR(m.string, 1, AT(c_null,m.string)-1)
RETURN IIF(EMPTY(m.string), m.default, m.string)

******************************************************************************
*
* Menu Code Generator's Main Module.
*
******************************************************************************

*
* BUILD - Generate code for a menu.
*
* Description:
* Call BUILDENABLE to open .MNX database specified by the user.
* If the above is successfully accomplished, then proceed to generate
* the menu code.  After the menu code is generated, call BUILDDISABLE
* to disable code generation between SET TEXTMERGE ON and
* SET TEXTMERGE OFF.
*
FUNCTION BUILD
IF NOT buildenable()
   RETURN
ENDIF
DO acttherm WITH c_msg_genmenucode_LOC   && Localization support [Rev: 2][MOD]
DO updtherm WITH 10
DO getmenutype
DO header
DO gensetupcleanup WITH "setup"
DO definemenu
DO definepopups
DO updtherm WITH 75
DO globaldefaults
DO updtherm WITH 95
DO gensetupcleanup WITH "cleanup"
DO genprocedures

IF m.g_graphic
   SET MESSAGE TO c_msg_gencomplete_LOC   && Localization support [Rev: 2][MOD]
ENDIF
DO builddisable
DO updtherm WITH 100
DO deactthermo

*
* BUILDENABLE - Enable code generation.
*
* Description:
* Call opendb to open .MNX database.
* Call openfile to open file to hold the generated program.
* If error(s) encountered in opendb or openfile then don't do
* anything and exit, otherwise enable code generation with the
* SET TEXTMERGE ON command.
*
* Returns:
* .T. on success; .F. on failure
*
FUNCTION buildenable
PRIVATE m.stat, m.stat2
m.stat = opendb(g_mnxfile[1]) AND openfile()
IF m.stat
   SET TEXTMERGE ON
ENDIF
RETURN m.stat

*
* BUILDDISABLE - Disable code generation.
*
* Description:
* Issue the command SET TEXTMERGE OFF.
* Close the generated menu code output file.
* If anything goes wrong display appropriate message to the user.
*
FUNCTION builddisable
SET ESCAPE OFF
ON ESCAPE
SET TEXTMERGE OFF
IF NOT FCLOSE(_TEXT)
   DO errorhandler WITH c_err_nocloseapp_LOC, LINENO(), c_error_2   && Localization support [Rev: 2][MOD]
ENDIF

*
* OPENDB - Prepare database for processing.
*
* Description:
* Attempt to USE a database.  If attempt fails and error is reported
* call ERRORHANDLER routine to display a friendly message.  Return
* with a status of .F..  If attempt succeeds, return with status of .T.
*
* Returns:
* .T. on success; .F. on failure
*
FUNCTION opendb
PARAMETER m.dbname
PRIVATE m.dbalias
ON ERROR DO errorhandler WITH MESSAGE(), LINENO(), c_error_2
m.dbalias = LEFT(basename(m.dbname),c_aliaslen)
IF USED (m.dbalias)
   SELECT (m.dbalias)
   IF RAT(".MNX",DBF())<>0
      g_mnxfile[3] = .F.
      g_mnxfile[4] = m.dbalias
   ELSE
      g_mnxfile[4] = "M"+SUBSTR(LOWER(SYS(3)),2,8)
      SELECT 0
      USE (m.dbname) AGAIN ALIAS (g_mnxfile[4])
      g_mnxfile[3] = .T.
   ENDIF
ELSE
   IF illegalname(m.dbalias)
      g_mnxfile[4] = "M"+SUBSTR(LOWER(SYS(3)),2,8)
   ELSE
      g_mnxfile[4] = m.dbalias
   ENDIF
   SELECT 0
   USE (m.dbname) AGAIN ALIAS (g_mnxfile[4])
   g_mnxfile[3] = .T.
ENDIF
IF FCOUNT() <> c_mnxflds
   IF FCOUNT() = c_20mnxflds
      m.g_20mnx = .T.
   ELSE
      DO errorhandler WITH c_err_badmnxpre_LOC + m.dbalias + c_err_badmnxpost_LOC, ;
         LINENO(), c_error_2   && Localization support [Rev: 2][MOD]
      RETURN .F.
   ENDIF
ELSE
   m.g_20mnx = .F.
ENDIF
ON ERROR DO errorhandler WITH MESSAGE(), LINENO(), c_error_3
IF m.g_error = .T.
   RETURN .F.
ENDIF

*
* ILLEGALNAME - Check if default alias will be used when this
*               database is USEd. (i.e., 1st letter is not A-Z,
*                a-z or '_', or any one of ramaining letters is not
*                alphanumeric.)
*
FUNCTION illegalname
PARAMETER m.menuname
PRIVATE m.start, m.aschar, m.length
m.length = LEN(m.menuname)
m.start  = 0
IF m.length = 1
   *
   * If length 1, then check if default alias can be used,
   * i.e., name is different than A-J and a-j.
   *
   m.aschar = ASC(m.menuname)
   IF (m.aschar >= 65 AND m.aschar <= 74) OR ;
         (m.aschar >= 97 AND m.aschar <= 106)
      RETURN .T.
   ENDIF
ENDIF
DO WHILE m.start < m.length
   m.start  = m.start + 1
   m.aschar = ASC(SUBSTR(m.menuname, m.start, 1))
   IF m.start<>1 AND (m.aschar >= 48 AND m.aschar <= 57)
      LOOP
   ENDIF
   IF NOT ((m.aschar >= 65 AND m.aschar <= 90) OR ;
         (m.aschar >= 97 AND m.aschar <= 122) OR m.aschar = 95)
      RETURN .T.
   ENDIF
ENDDO
RETURN .F.

*
* OPENFILE - Create and open the application output file.
*
* Description:
* Create a file that will hold the generated menu code.
* Open the newly created file.  If error(s) encountered
* at any time issue an error message and return .F.
*
* Returns:
* .T. on success; .F. on failure
*
FUNCTION openfile
PRIVATE m.msg
_TEXT = FCREATE(m.g_outfile)
IF (_TEXT = -1)
   m.msg = c_err_nofileopen_LOC + m.g_outfile   && Localization support [Rev: 2][MOD]
   DO errorhandler WITH m.msg, LINENO(), c_error_3
   m.g_nohandle = .T.
   RETURN .F.
ENDIF
m.g_nohandle = .F.

*
* DEFINEMENU - Define main menu and its pads.
*
* Description:
* Issue DEFINE MENU ... command.
* Call a procedure to define all menu pads.
* Call a procedure to generate ON PAD statements when appropriate.
*
FUNCTION definemenu
IF m.g_graphic
   SET MESSAGE TO c_msg_genmenudefs_LOC   && Localization support [Rev: 2][MOD]
ENDIF
DO commentblock WITH "menu"
SELECT (g_mnxfile[4])

IF m.g_shortcut
    RETURN    && skip if shortcut menu
ENDIF

LOCATE FOR objtype = c_menu
IF EOF()
    * using Top-Level menu instead
    LOCATE FOR objtype = c_sdimenu
ENDIF
m.g_location = location

m.g_padloca  = ALLTRIM(name)
LOCATE FOR objtype = c_submenu AND objcode = c_global
m.g_menucolor = SCHEME
m.g_menumark  = MARK

DO CASE
CASE m.g_inform AND m.g_location = c_replace
    \DEFINE MENU (m.cMenuName) IN (m.oFormRef.Name) BAR
CASE m.g_inform
    \LOCAL lHasNewMenu
    \lHasNewMenu = (TYPE("CNTPAD(m.cMenuName)") # "N")
    \IF m.lHasNewMenu
    \    DEFINE MENU (m.cMenuName) IN (m.oFormRef.Name) BAR
    \ENDIF
CASE (m.g_location >= 4 OR m.g_location=c_replace)
    * Special BiDi handling
    IF (m.g_location >= 4)
        m.g_location = m.g_location - 4
        IF sys(4015)=1
            \SET SYSMENU TO RTLJUSTIFY
        ENDIF
    ENDIF
    IF m.g_location = c_replace
        \SET SYSMENU TO
        \SET SYSMENU AUTOMATIC
    ENDIF
ENDCASE

\
DO updtherm WITH 25
DO defmenupads
DO updtherm WITH 35
DO defonpad
\
DO updtherm WITH 45

*
* DEFMENUPADS - Define all pads for the menu bar.
*
* Description:
* Scan the menu database for all objects of the type item which
* have the levelname=_MSYSMENU.
* For each such item, generate a statement DEFINE PAD... where
* the name of the pad is the contents of NAME field or (if Name
* field is empty) an automatically generated name.
* Call procedures addkey, addskipfor, and mark to generate
* KEY, SKIPFOR, or MARK clauses when appropriate.
*
FUNCTION defmenupads
PRIVATE m.padname, m.prompt
LOCAL lcNegotiate    && Add support for OLE2 Negotiate [Rev: 2][MOD]
LOCAL lcNegContainer && Add support for ActiveDoc Negotiate
LOCAL lcNegObject     && Add support for ActiveDoc Negotiate
SCAN FOR objtype=c_item AND UPPER(levelname)="_MSYSMENU"
   IF NOT EMPTY(ALLTRIM(name))
      g_pads[VAL(Itemnum)] = name
   ELSE
      g_pads[VAL(Itemnum)] = LOWER(SYS(2015))
   ENDIF
   DO CASE
   CASE m.g_inform
           \DEFINE PAD <<g_pads[VAL(Itemnum)]>> OF (m.cMenuName)
   OTHERWISE
           \DEFINE PAD <<g_pads[VAL(Itemnum)]>> OF _MSYSMENU
   ENDCASE
   IF MOD(VAL(itemnum),25)=0
      DIMENSION g_pads[VAL(Itemnum)+25]
   ENDIF
   m.prompt = SUBSTR(PROMPT,1,LEN(PROMPT))
   \\ PROMPT "<<m.prompt>>"
   \\ COLOR SCHEME <<m.g_menucolor>>

   IF m.g_menumark<>c_null AND m.g_menumark<>""
      \\ ;
      \    MARK "<<m.g_menumark>>"
   ENDIF

   DO CASE
      CASE m.g_location = c_before
         \\ ;
         \    BEFORE <<m.g_padloca>>
      CASE m.g_location = c_after
         \\ ;
         \    AFTER
         IF VAL(itemnum) = 1
            \\ <<m.g_padloca>>
         ELSE
            \\ <<g_pads[VAL(Itemnum)-1]>>
         ENDIF
   ENDCASE
   * Add support for OLE2 Negotiate [Rev: 2][BEG]
   *    c_neg_flag is a quote delimited constant for the field that must be evaluated
   *    for a legal negotiate value.
   lcNegotiate = EVAL( c_neg_flag )
   IF NOT EMPTY( m.lcNegotiate )
      m.lcNegContainer = BITAND(m.lcNegotiate, 0x000F)
      m.lcNegObject = BITRSHIFT(BITAND(m.lcNegotiate, 0x00F0), 4)
      \\ ;
      \    NEGOTIATE
      DO CASE
         CASE m.lcNegContainer = c_neg_none
            \\ NONE,
         CASE m.lcNegContainer = c_neg_left
            \\ LEFT,
         CASE m.lcNegContainer = c_neg_middle
            \\ MIDDLE,
         CASE m.lcNegContainer = c_neg_right
            \\ RIGHT,
         OTHERWISE
            DO errorhandler WITH c_err_badnegoval_LOC + c_neg_flag ,;
               LINENO(),c_error_2   && Localization support [Rev: 2][MOD]
      ENDCASE
      DO CASE
         CASE m.lcNegObject = c_neg_none
            \\ NONE
         CASE m.lcNegObject = c_neg_left
            \\ LEFT
         CASE m.lcNegObject = c_neg_middle
            \\ MIDDLE
         CASE m.lcNegObject = c_neg_right
            \\ RIGHT
         OTHERWISE
            DO errorhandler WITH c_err_badnegoval_LOC + c_neg_flag ,;
               LINENO(),c_error_2   && Localization support [Rev: 2][MOD]
      ENDCASE
   ENDIF
   RELEASE m.negotiate
   * Add support for OLE2 Negotiate [Rev: 2][END]
   DO addkey
   DO addskipfor
   DO addmessage
ENDSCAN


*
* DEFONPAD - Generate ON PAD... statements.
*
* Description:
* Generate ON PAD statements for each pad off of the main menu which
* has a submenu associated with it.
* For pads which have no submenus, but there is a command associated
* with them, issue ON SELECTION PAD... statements.  If the code
* associated with a pad is a snippet, then issue a call to the
* generated procedure and place the snippet code in it.
*
FUNCTION defonpad
PRIVATE m.padname
SCAN FOR objtype=c_item AND UPPER(levelname)="_MSYSMENU"
   IF NOT EMPTY(ALLTRIM(name))
      m.padname = name
   ELSE
      m.padname = g_pads[VAL(Itemnum)]
   ENDIF
   m.therec = RECNO()
   SKIP
   IF objtype=c_submenu AND numitems<>0
       IF m.g_inform
          \ON PAD <<m.padname>> OF (m.cMenuName)
          \\ ACTIVATE POPUP (a_menupops[<<ASCAN(g_apops,LOWER(Name))>>])
       ELSE
          \ON PAD <<m.padname>> OF _MSYSMENU
          \\ ACTIVATE POPUP <<LOWER(Name)>>
       ENDIF
      GOTO m.therec
   ELSE
      GOTO m.therec
      DO onselection WITH "pad", m.padname, '_MSYSMENU'
   ENDIF
ENDSCAN



*
* DEFINEPOPUPS - Define popups and their bars.
*
* Description:
* Scan the Menu database to find all objecttypes = submenu.
* They all correspond to popups.  For each such object found, issue
* command DEFINE POPUP....  Add MARK, KEY, and SKIP FOR clauses
* if appropriate by calling procedures to handle these tasks.  Call
* procedure Defbars to define all bars of each popup.
*
FUNCTION definepopups
PRIVATE m.savrecno, m.popname, m.sch, m.firstpop,m.newpopname
m.firstpop = .T.
IF m.g_graphic
   SET MESSAGE TO c_msg_genpopdefs_LOC   && Localization support [Rev: 2][MOD]
ENDIF
SCAN FOR objtype=c_submenu AND UPPER(levelname)<>"_MSYSMENU" ;
      AND numitems <> 0
   m.savrecno = RECNO()
   m.popname  = ALLTRIM(LOWER(levelname))
   m.newpopname = m.popname
   m.sch = SCHEME
   DO CASE
   CASE m.g_shortcut AND m.firstpop
           * safeguard against system popups used for top popup name
           IF LOWER(LEFT(Name,2))="_m"
               * Use default name
            STORE c_shortcutdef_loc TO m.newpopname,m.g_shortcutname
           ELSE
               m.g_shortcutname = LOWER(Name)
           ENDIF
        m.firstpop = .F.
       \DEFINE POPUP <<m.g_shortcutname>> SHORTCUT RELATIVE FROM MROW(),MCOL()
   CASE m.g_shortcut
       \DEFINE POPUP <<LOWER(Name)>> SHORTCUT RELATIVE
  CASE m.g_inform
       \DEFINE POPUP (a_menupops[<<ASCAN(g_apops,LOWER(Name))>>]) MARGIN RELATIVE SHADOW
       \\ COLOR SCHEME <<m.sch>>
   OTHERWISE
       \DEFINE POPUP <<LOWER(Name)>> MARGIN RELATIVE SHADOW
       \\ COLOR SCHEME <<m.sch>>
   ENDCASE
   DO addmark
   DO addkey
   DO defbars WITH m.popname, numitems, m.newpopname
   DO defonbar WITH m.popname, m.newpopname
   \
   GOTO RECORD m.savrecno
ENDSCAN


*
* DEFBARS - Define bars for each popup.
*
* Description:
* Scan the menu database for all objects of the type item whose
* name equals to the current popup name.
* For each such item, generate a statement DEFINE BAR....
* Call procedures addkey, addskipfor, and addmark to generate
* KEY, SKIPFOR, or MARK clauses when appropriate.
*
FUNCTION defbars
PARAMETER m.popname, m.howmany, m.newname
IF EMPTY(m.newname)
    m.newname = m.popname
ENDIF
PRIVATE m.itemno, m.prompt,m.name, m.cPopExpr
SCAN FOR objtype=c_item AND LOWER(levelname)=m.popname
   m.itemno = ALLTRIM(itemnum)
   m.cPopExpr = IIF(m.g_inform, "(a_menupops["+ALLTRIM(STR(ASCAN(g_apops,LOWER(m.newname))))+"])", LOWER(m.newname))
   IF NOT EMPTY(ALLTRIM(name))
      m.name = name
      \DEFINE BAR <<m.name>> OF <<m.cPopExpr>>
   ELSE
      \DEFINE BAR <<m.itemno>> OF <<m.cPopExpr>>
   ENDIF
   m.prompt = SUBSTR(PROMPT, 1,LEN(PROMPT))
   \\ PROMPT "<<m.prompt>>"
   DO addmark
   DO addkey
   DO addskipfor
   DO addmessage
   IF VAL(m.itemno)=m.howmany
      RETURN
   ENDIF
ENDSCAN

*
* DEFONBAR - Generate ON BAR... statements.
*
* Description:
* Generate ON BAR statements for each popup.
* For bars which have no submenus, but there is a command associated
* with them, issue ON SELECTION BAR... statements.  If a snippet is
* associated with the code then generate a call statement to the
* generated procedure containing the snippet code.
*
FUNCTION defonbar
PARAMETER m.popname,m.newname
PRIVATE m.itemno,  m.cPopExpr ,  m.cPopExpr2
IF EMPTY(m.newname)
    m.newname = m.popname
ENDIF
SCAN FOR objtype=c_item AND LOWER(levelname)=m.popname
   IF EMPTY(ALLTRIM(name))
      m.itemno = ALLTRIM(itemnum)
   ELSE
      m.itemno = name
   ENDIF
   SKIP
   m.cPopExpr = IIF(m.g_inform, "(a_menupops["+ALLTRIM(STR(ASCAN(g_apops,LOWER(m.newname))))+"])", LOWER(m.newname))
   m.cPopExpr2 = IIF(m.g_inform, "(a_menupops["+ALLTRIM(STR(ASCAN(g_apops,LOWER(name))))+"])", LOWER(name))

   IF objtype=c_submenu AND numitems<>0
      \ON BAR <<m.itemno>> OF <<m.cPopExpr>>
      \\ ACTIVATE POPUP <<m.cPopExpr2>>
      SKIP -1
   ELSE
      SKIP -1
      DO onselection WITH "BAR", m.itemno, m.newname
   ENDIF
ENDSCAN

*
* GLOBALDEFAULTS - Generate global default statements
*
* Description:
* Search the menu database for information needed to generate any of
* the following commands:
* ON SELECTION MENU <name> DO <action>
* ON SELECTION POPUP ALL DO <action>
* ON SELECTION POPUP <name> DO <action>
* It is possible that none of the above mentioned statements will be
* generated.  It is also possible that the action is a snippet of
* code and a call to the generated procedure containing the snippet
* will be generated.
*
* First try to generate ON SELECTION MENU...
* Then try to generate ON POPUP ALL...
* Lastly, try to generate ON SELECTION POPUP...
*
FUNCTION globaldefaults
LOCATE FOR objtype = c_menu
LOCAL m.cPopExpr
m.mrk = MARK
IF FOUND() AND MARK <> ""
   IF MARK = c_null
      \SET MARK OF MENU _MSYSMENU TO " "
   ELSE
      \SET MARK OF MENU _MSYSMENU TO "<<Mark>>"
   ENDIF
ENDIF
IF FOUND() AND NOT EMPTY(PROCEDURE)
   \ON SELECTION MENU _MSYSMENU
   DO genproccall
ENDIF
LOCATE FOR objtype = c_submenu AND objcode = c_global
IF FOUND() AND NOT EMPTY(PROCEDURE)
   \ON SELECTION POPUP ALL
   DO genproccall
ENDIF
SCAN FOR (objtype=c_submenu AND UPPER(levelname)<>"_MSYSMENU";
      AND NOT EMPTY(PROCEDURE))
  m.cPopExpr = IIF(m.g_inform, "(a_menupops["+ALLTRIM(STR(ASCAN(g_apops,ALLTRIM(LOWER(Levelname)))))+"])", ALLTRIM(LOWER(Levelname)))
   \ON SELECTION POPUP <<m.cPopExpr>>
   DO genproccall
ENDSCAN


******************************************************************************
*
* Subroutines for processing menu clause options.
*
******************************************************************************
*
* ADDMARK - Generate a MARK clause whenever appropriate.
*
* Description:
* Add a MARK clause to the current PAD or BAR definition.
* If a field named Mark is not empty, then add the continuation
* character, ";", to the previous line, and then add the MARK... clause.
*
FUNCTION addmark
IF MARK<>c_null AND MARK<>""
   \\ ;
   \    MARK "<<Mark>>"
ENDIF



*
* ADDKEY - Generate KEY... clause whenever appropriate.
*
* Description:
* Add a KEY clause to the current PAD or BAR definition.
* If a field named Keyname is not empty, then add the continuation
* character, ";", to the previous line, and then add the KEY... clause.
*
FUNCTION addkey
* Add support for intelligent Pad hotkeys. [Rev: 7][BEG]
* NOTE: For consistency, Pads no longer respect keyname and
*       keylabel, they use the letter following "\<" or the
*       first letter of the prompt of none is defined.
LOCAL cKeyname, cKeylabel, nPosition
IF objtype=c_item AND ;
   UPPER(levelname)="_MSYSMENU" AND ;
   EMPTY(keyname)
   nPosition = AT_C("\<",prompt)
   IF m.nPosition > 0 AND NOT EMPTY(SUBSTRC(prompt,m.nPosition+2,1))
      STORE c_key_padhotkey_LOC + UPPER(SUBSTRC(prompt,m.nPosition+2,1)) TO m.cKeyname
   ELSE
      IF !IsLeadByte(prompt)
          STORE c_key_padhotkey_LOC + UPPER(LEFT(prompt,1)) TO m.cKeyname
      ELSE
          STORE "" to m.cKeyname
      ENDIF
   ENDIF
   cKeylabel = ""
ELSE
   cKeyname  = keyname
   cKeylabel = keylabel
ENDIF
IF NOT EMPTY(m.cKeyname)
   \\ ;
   \    KEY <<m.cKeyname>>, "<<m.cKeylabel>>"
ENDIF
* Add support for intelligent Pad hotkeys. [Rev: 7][END]



*
* ADDSKIPFOR - Generate SKIP FOR... clause whenever appropriate.
*
* Description:
* Add a ADDSKIPFOR clause to the current PAD or BAR definition.
* If a field named Addskipfor is not empty, then add the continuation
* character, ";", to the previous line, and then add the SKIP FOR...
* clause.
*
FUNCTION addskipfor
PRIVATE m.skip
m.skip = skipfor
IF NOT EMPTY(skipfor)
   \\ ;
   \    SKIP FOR <<m.skip>>
ENDIF



*
* ADDMESSAGE - Generate MESSAGE clause whenever appropriate.
*
* Description:
* Add a MESSAGE clause to the current PAD or BAR definition.
* If a field named MESSAGE is not empty and it is not a 2.0 menu,
* then add the continuation character, ";", to the previous line,
* and then add the MESSAGE clause.
*
FUNCTION addmessage
IF !m.g_20mnx AND NOT EMPTY(MESSAGE)
   \\ ;
   \    MESSAGE <<Message>>
ENDIF



*
* HEADER - Generate generated program's header.
*
* Description:
* As a part of the automatically generated program's header generate
* program name, name of the author of the program, copyright notice,
* company name and address, and the word 'Description:' which will be
* followed with a short description of the generated code.
*
FUNCTION HEADER
\\*       <<m.g_corn1>><<REPLICATE(m.g_horiz,57)>><<m.g_corn2>>
\*       <<m.g_verti1>><<REPLICATE(" ",57)>><<m.g_verti2>>
\*       <<m.g_verti1>> <<DATE()>>
\\<<PADC(UPPER(ALLTRIM(strippath(m.g_outfile))),IIF(SET("CENTURY")="ON",35,37))," ")>>
\\ <<TIME()>>  <<m.g_verti2>>
\*       <<m.g_verti1>><<REPLICATE(" ",57)>><<m.g_verti2>>
\*       <<m.g_corn5>><<REPLICATE(m.g_horiz,57)>><<m.g_corn6>>
\*       <<m.g_verti1>><<REPLICATE(" ",57)>><<m.g_verti2>>
\*       <<m.g_verti1>> <<m.g_devauthor>>
\\<<REPLICATE(" ",max(1,56-LEN(m.g_devauthor)))>><<m.g_verti2>>
\*       <<m.g_verti1>><<REPLICATE(" ",57)>><<m.g_verti2>>
\*       <<m.g_verti1>>
*- Localization support [Rev: 2][MOD]
\\ c_hdr_copyright_LOC <<YEAR(DATE())>>
IF LEN(ALLTRIM(m.g_devcompany)) <= 36
   \\ <<ALLTRIM(m.g_devcompany)>>
   \\<<REPLICATE(" ",max(1,37-LEN(ALLTRIM(m.g_devcompany))))>>
   \\<<m.g_verti2>>
ELSE
   \\ <<REPLICATE(" ",37)>><<m.g_verti2>>
   \*       <<m.g_verti1>> <<m.g_devcompany>>
   \\<<REPLICATE(" ",max(1,56-LEN(m.g_devcompany)))>><<m.g_verti2>>
ENDIF

\*       <<m.g_verti1>> <<m.g_devaddress>>
\\<<REPLICATE(" ",max(1,56-LEN(m.g_devaddress)))>><<m.g_verti2>>

\*       <<m.g_verti1>> <<ALLTRIM(m.g_devcity)>>, <<m.g_devstate>>
\\  <<ALLTRIM(m.g_devzip)>>
\\<<REPLICATE(" ",50-(LEN(ALLTRIM(m.g_devcity)+ALLTRIM(m.g_devzip))))>>
\\<<m.g_verti2>>

IF !INLIST(ALLTRIM(UPPER(m.g_devctry)),"USA","COUNTRY") AND !EMPTY(m.g_devctry)
   \*       <<m.g_verti1>> <<ALLTRIM(m.g_devctry)>>
   \\<<REPLICATE(" ",50-(LEN(ALLTRIM(m.g_devctry))))>>
   \\<<m.g_verti2>>
ENDIF
\*       <<m.g_verti1>><<REPLICATE(" ",57)>><<m.g_verti2>>
*- Localization support [Rev: 2][MOD]
\*       <<m.g_verti1>> c_hdr_descript_LOC
\\                                            <<m.g_verti2>>
\*       <<m.g_verti1>>
*- Localization support [Rev: 2][MOD]
\\ c_hdr_string_LOC
\\    <<m.g_verti2>>
\*       <<m.g_verti1>><<REPLICATE(" ",57)>><<m.g_verti2>>
\*       <<m.g_corn3>><<REPLICATE(m.g_horiz,57)>><<m.g_corn4>>
\



*
* GENFUNCHEADER - Generate Comment for Function/Procedure.
*
FUNCTION genfuncheader
PARAMETER m.procname
PRIVATE m.place, m.prompt
m.g_snippcnt = m.g_snippcnt + 1
DO CASE
   CASE objtype = c_menu
      m.place = "ON SELECTION MENU _MSYSMENU"
   CASE objtype = c_submenu AND objcode = c_global
      m.place = "ON SELECTION POPUP ALL"
   CASE objtype = c_submenu AND objcode <> c_global
      m.place = "ON SELECTION POPUP "+LOWER(ALLTRIM(name))
   CASE objtype = c_item AND UPPER(levelname) = "_MSYSMENU"
      m.place = "ON SELECTION PAD "
   CASE objtype = c_item AND UPPER(levelname) <> "_MSYSMENU"
      m.place = "ON SELECTION BAR "+ALLTRIM(itemnum)+;
         +" OF POPUP "+LOWER(ALLTRIM(levelname))
   OTHERWISE
      m.place = ""
ENDCASE
\
\*       <<m.g_corn1>><<REPLICATE(m.g_horiz,57)>><<m.g_corn2>>
\*       <<m.g_verti1>><<REPLICATE(" ",57)>><<m.g_verti2>>
\*       <<m.g_verti1>> <<UPPER(PADR(m.procname,10))>>  <<m.place>>
\\<<REPLICATE(" ",max(1,max(1,44-LEN(m.place))))>><<m.g_verti2>>
\*       <<m.g_verti1>><<REPLICATE(" ",57)>><<m.g_verti2>>
\*       <<m.g_verti1>> Procedure Origin:
\\<<REPLICATE(" ",39)>><<m.g_verti2>>
\*       <<m.g_verti1>><<REPLICATE(" ",57)>><<m.g_verti2>>
\*       <<m.g_verti1>> From Menu:
\\  <<ALLTRIM(strippath(m.g_outfile))>>
\\,            Record:  <<STR(RECNO(),3)>>
\\<<REPLICATE(" ",max(1,max(1,22-LEN(ALLTRIM(strippath(m.g_outfile))+STR(RECNO(),3))))))>>
\\<<m.g_verti2>>
\*       <<m.g_verti1>> Called By:  <<m.place>>
\\<<REPLICATE(" ",max(1,max(1,44-LEN(m.place))))>><<m.g_verti2>>
IF NOT EMPTY(PROMPT)
   m.prompt = removemeta()
   \*       <<m.g_verti1>> Prompt:     <<ALLTRIM(m.prompt)>>
   \\<<REPLICATE(" ",max(1,44-LEN(ALLTRIM(m.prompt))))>><<m.g_verti2>>
ENDIF
\*       <<m.g_verti1>> Snippet:
\\    <<ALLTRIM(STR(m.g_snippcnt,2))>>
\\<<REPLICATE(" ",max(1,44-LEN(ALLTRIM(STR(m.g_snippcnt,2)))))>><<m.g_verti2>>
\*       <<m.g_verti1>><<REPLICATE(" ",57)>><<m.g_verti2>>
\*       <<m.g_corn3>><<REPLICATE(m.g_horiz,57)>><<m.g_corn4>>
\*



*
* REMOVEMETA - Remove meta characters for documentation.
*
FUNCTION removemeta
PRIVATE m.prompt, m.hotkey
m.prompt = PROMPT
m.hotkey = AT("\<",m.prompt)
IF m.hotkey <> 0
   m.prompt = STUFF(m.prompt,m.hotkey,2,"")
ENDIF
m.disabl = AT("\",m.prompt)
IF m.disabl <> 0
   m.prompt = STUFF(m.prompt,m.disabl,1,"")
ENDIF
RETURN m.prompt


*
* COMMENTBLOCK - Generate a comment block.
*
FUNCTION commentblock
PARAMETER m.snippet
\
\*       <<m.g_corn1>><<REPLICATE(m.g_horiz,57)>><<m.g_corn2>>
\*       <<m.g_verti1>><<REPLICATE(" ",57)>><<m.g_verti2>>
DO CASE
   CASE m.snippet == "setup"
      \*       <<m.g_verti1>>
      *- Localization support [Rev: 2][MOD]
      \\ <<PADC( c_snip_setup_LOC ,56," ")>>
   CASE m.snippet == "cleanup"
      \*       <<m.g_verti1>>
      *- Localization support [Rev: 2][MOD]
      \\ <<PADC( c_snip_cleanup_LOC ,56," ")>>
   CASE m.snippet == "init"
      \*       <<m.g_verti1>>
      *- Localization support [Rev: 2][MOD]
      \\ <<PADC( c_snip_init_LOC ,56," ")>>
   CASE m.snippet == "menu"
      \*       <<m.g_verti1>>
      *- Localization support [Rev: 2][MOD]
      \\ <<PADC( c_snip_menu_LOC ,56," ")>>
ENDCASE
\\<<m.g_verti2>>
\*       <<m.g_verti1>><<REPLICATE(" ",57)>><<m.g_verti2>>
\*       <<m.g_corn3>><<REPLICATE(m.g_horiz,57)>><<m.g_corn4>>
\*
\

*
* ONSELECTION - Generate ON SELECTION... statements for menu items.
*
* Description:
* For pads and bars which have no submenu associated with them but
* instead have a non-empty Command field in the database, issue
* the ON SELECTION <command> statements.  If a snippet is associated
* with a pad then issue a call statement to the generated procedure
* containing the snippet.  Generated snippet procedure will be
* appended to the end of the output file.
*
FUNCTION onselection
PARAMETER m.which, m.name, m.ofname
PRIVATE m.trimname, m.basename, m.commd, m.cPopExpr
IF EMPTY(PROCEDURE) AND EMPTY(COMMAND)
   RETURN
ENDIF

DO CASE
   CASE m.which == "pad"
      \ON SELECTION PAD <<m.name>>
   CASE m.which == "BAR"
      \ON SELECTION <<m.which+" "+m.name>>
ENDCASE

IF m.g_inform AND !m.g_shortcut AND m.which#"BAR"
    \\ OF (m.cMenuName)
ELSE
    m.cPopExpr = IIF(m.g_inform, "(a_menupops["+ALLTRIM(STR(ASCAN(g_apops,m.ofname)))+"])",m.ofname)
    \\ OF <<m.cPopExpr>>
ENDIF

IF objcode = c_proc
   DO gensnippname
   m.trimname = SYS(2014,UPPER(m.g_outfile),UPPER(m.g_homedir))
   m.trimname = stripext(m.trimname)
   m.basename = basename(m.trimname)
   \\ ;
   \    DO <<g_snippets[g_nsnippets,1]>> ;
   \    IN LOCFILE("<<m.trimname>>"
   \\ ,"MPX;MPR|FXP;PRG"
   \\ ,"
   *- Localization support [Rev: 2][MOD]
   \\c_ui_whereis_LOC
   \\ <<m.basename>>?")
ELSE
   m.commd = COMMAND
   \\ <<m.commd>>
ENDIF



*
* GENSNIPPNAME - Generate a unique name for snippet procedure.
*
* Description:
* Lookup the #NAME name of this snippet, or alternatively
* provide a unique name for a snippet of code associated with the
* generated menu.  Save this name in an array g_snippets.
*
FUNCTION gensnippname
g_nsnippets = g_nsnippets + 1
g_snippets[g_nsnippets,1] = getcname(PROCEDURE)
g_snippets[g_nsnippets,2] = RECNO()
IF MOD(g_nsnippets,25) = 0
   DIMENSION g_snippets [g_nsnippets+25,2]
ENDIF



*
* GENPROCCALL - Generate a call statement to snippet procedure.
*
* Description:
* Generate a call to the snippet procedure in the menu definition
* code.
*
FUNCTION genproccall
PRIVATE m.trimname, m.basename, m.proc
IF singleline()
   m.proc = PROCEDURE
   \\ <<MLINE(m.proc,1)>>
ELSE
   DO gensnippname
   m.trimname = SYS(2014,UPPER(m.g_outfile),UPPER(m.g_homedir))
   m.trimname = stripext(m.trimname)
   m.basename = basename(m.trimname)
   \\ ;
   \    DO <<g_snippets[m.g_nsnippets,1]>> ;
   \    IN LOCFILE("<<m.trimname>>"
   \\ ,"MPX;MPR|FXP;PRG"
   \\ ,"
   *- Localization support [Rev: 2][MOD]
   \\c_ui_whereis_LOC
   \\ <<m.basename>>?")
ENDIF



*
* SINGLELINE - Determine if Memo contains only one line.
*
* Description:
* This procedure is used to decide if an ON SELECTION... statement
* and a snippet procedure will be needed (i.e., if more than one
* line of snippet code then its a snippet, otherwise its a command)
*
FUNCTION singleline
PRIVATE m.size, m.i
m.size = MEMLINES(PROCEDURE)
IF m.size = 1
   RETURN .T.
ENDIF
m.i = m.size
DO WHILE m.i > 1
   m.line = MLINE(PROCEDURE, m.i)
   IF NOT EMPTY(m.line)
      RETURN .F.
   ENDIF
   m.i = m.i - 1
ENDDO



*
* GENPROCEDURES - Generate procedure/snippet code.
*
* Description:
* Generate 'PROCEDURE procedurename' statement and its body.
*
FUNCTION genprocedures
PRIVATE m.i
IF m.g_graphic
   SET MESSAGE TO c_msg_genprocs_LOC   && Localization support [Rev: 2][MOD]
ENDIF
FOR m.i = 1 TO m.g_nsnippets
   GOTO RECORD (g_snippets[m.i,2])
   DO genfuncheader WITH g_snippets[m.i,1]
   \PROCEDURE <<g_snippets[m.i,1]>>
   DO writecode WITH PROCEDURE
   \
ENDFOR



*
* WRITECODE - Write contents of a memo to a low level file.
*
* Description:
* Receive a memo field as a parameter and write its contents out
* to the currently opened low level file whose handle is stored
* in the system memory variable _TEXT.  Contents of the system
* memory variable _pretext will affect the positioning of the
* generated text.
*
FUNCTION writecode
PARAMETER m.memo, m.codefield
PRIVATE m.lines, m.i, m.thisline, m.lHadActPopup
IF TYPE("m.codefield") # "C"
    m.codefield = ""
ENDIF
m.lHadActPopup = .F.
m.lines = MEMLINES(m.memo)
_MLINE = 0
FOR m.i = 1 TO m.lines
   m.thisline = MLINE(m.memo, 1, _MLINE)
   DO CASE
   CASE m.g_shortcut  AND m.codefield=="cleanup" AND  !m.lHadActPopup AND LEFT(UPPER(LTRIM(m.thisline)),5) == "#PREP"    && #PREPOPUP in Cleanup
    DO actpopup
    m.lHadActPopup = .T.
    m.g_prepopup = .F.
   CASE m.g_shortcut AND m.codefield#"cleanup" AND LEFT(UPPER(LTRIM(m.thisline)),5) == "#PREP"        && #PREPOPUP in Setup
    m.g_prepopup = .T.
   CASE LEFT(UPPER(LTRIM(m.thisline)),5) == "#INSE"   && #INSERT
        DO GenInsertCode WITH m.thisline
   CASE INLIST(LEFT(UPPER(LTRIM(m.thisline)),5) ,"#NAME","#PREP")    &&skip #PREP for non Shortcut menus
    * Do nothing
   OTHERWISE
         \<<m.thisline>>
   ENDCASE
ENDFOR



*
* GENSETUPCLEANUP - Generate setup/cleanup code.
*
FUNCTION GenSetupCleanup
PARAMETER m.choice
LOCATE FOR objtype = IIF(m.g_shortcut,c_shortcut,IIF(m.g_inform,c_sdimenu,c_menu))
DO CASE
   CASE m.choice == "setup"
      IF m.g_inform
         DO sdiheader
      ENDIF
      IF EMPTY(setup)
         RETURN
      ENDIF
      IF m.g_graphic
         SET MESSAGE TO c_msg_gensetup_LOC   && Localization support [Rev: 2][MOD]
      ENDIF
      DO commentblock WITH m.choice
      DO writecode WITH setup
   CASE m.choice == "cleanup"
      IF !m.g_prepopup AND ATC("#PREP",cleanup)=0
              DO actpopup
      ENDIF
      IF !EMPTY(cleanup)
          IF m.g_graphic
             SET MESSAGE TO c_msg_gencleanup_LOC   && Localization support [Rev: 2][MOD]
          ENDIF
          DO commentblock WITH m.choice
          DO writecode WITH cleanup,m.choice
    ENDIF
      IF m.g_prepopup
              DO actpopup
      ENDIF
ENDCASE


*
* GENINSERTCODE - Emit code from the #insert file, if any
*
FUNCTION GenInsertCode
PARAMETER strg
PRIVATE m.word1, m.filname, m.ins_fp, m.buffer
IF UPPER(LEFT(LTRIM(m.strg),5)) == "#INSE"
   m.word1 = wordnum(m.strg,1)
   m.filname = SUBSTR(m.strg,LEN(m.word1)+1)
   m.filname = ALLTRIM(CHRTRAN(m.filname,CHR(9),""))

   * Bail out if we can't find the file either explicitly or on the DOS path
   IF !FILE(m.filname)
      filname = FULLPATH(m.filname,1)
      IF !FILE(m.filname)
         \*Insert file <<m.filname>> could not be found
         RETURN
      ENDIF
   ENDIF

   ins_fp = FOPEN(m.filname)
   IF ins_fp > 0
      \* Inserted from <<strippath(m.filname)>>
      DO WHILE !FEOF(ins_fp)
         m.buffer = FGETS(ins_fp)
         \<<m.buffer>>
      ENDDO
      =FCLOSE(m.ins_fp)
      \* End of inserted lines
   ENDIF
ENDIF


******************************************************************************
*
* Code assocated with thermometer.
*
******************************************************************************
*
* ACTTHERM(<text>) - Activate thermometer.
*
* Description:
* Activates thermometer.  Update the thermometer with UPDTHERM().
* Thermometer window is named "thermometer."  Be sure to RELEASE
* this window when done with thermometer.  Creates the global
* m.g_thermwidth.
*
FUNCTION acttherm
PARAMETER m.text
PRIVATE m.prompt
IF m.g_graphic
   m.prompt = m.g_outfile
   m.prompt = thermfname(m.prompt)
   DO CASE
      CASE _WINDOWS
           LOCAL cWinColor
           cWinColor = rgbscheme(1, 2)
         DEFINE WINDOW thermomete ;
            AT  INT((SROW() - (( 5.615 * ;
            FONTMETRIC(1, m.g_dlgface, m.g_dlgsize, m.g_dlgstyle )) / ;
            FONTMETRIC(1, WFONT(1,""), WFONT( 2,""), WFONT(3,"")))) / 2), ;
            INT((SCOL() - (( 63.833 * ;
            FONTMETRIC(6, m.g_dlgface, m.g_dlgsize, m.g_dlgstyle )) / ;
            FONTMETRIC(6, WFONT(1,""), WFONT( 2,""), WFONT(3,"")))) / 2) ;
            SIZE 5.615,63.833 ;
            FONT m.g_dlgface, m.g_dlgsize ;
            STYLE m.g_dlgstyle ;
            NOFLOAT ;
            NOCLOSE ;
            NONE ;
            COLOR &cWinColor
         MOVE WINDOW thermomete CENTER
         ACTIVATE WINDOW thermomete NOSHOW
         @ 0.5,3 SAY m.text FONT m.g_dlgface, m.g_dlgsize STYLE m.g_dlgstyle
         @ 1.5,3 SAY m.prompt FONT m.g_dlgface, m.g_dlgsize STYLE m.g_dlgstyle
         @ 0.000,0.000 TO 0.000,63.833 ;
            COLOR RGB(255, 255, 255, 255, 255, 255)
         @ 0.000,0.000 TO 5.615,0.000 ;
            COLOR RGB(255, 255, 255, 255, 255, 255)
         @ 0.385,0.667 TO 5.231,0.667 ;
            COLOR RGB(128, 128, 128, 128, 128, 128)
         @ 0.308,0.667 TO 0.308,63.167 ;
            COLOR RGB(128, 128, 128, 128, 128, 128)
         @ 0.385,63.000 TO 5.308,63.000 ;
            COLOR RGB(255, 255, 255, 255, 255, 255)
         @ 5.231,0.667 TO 5.231,63.167 ;
            COLOR RGB(255, 255, 255, 255, 255, 255)
         @ 5.538,0.000 TO 5.538,63.833 ;
            COLOR RGB(128, 128, 128, 128, 128, 128)
         @ 0.000,63.667 TO 5.615,63.667 ;
            COLOR RGB(128, 128, 128, 128, 128, 128)
         @ 3.000,3.333 TO 4.231,3.333 ;
            COLOR RGB(128, 128, 128, 128, 128, 128)
         @ 3.000,60.333 TO 4.308,60.333 ;
            COLOR RGB(255, 255, 255, 255, 255, 255)
         @ 3.000,3.333 TO 3.000,60.333 ;
            COLOR RGB(128, 128, 128, 128, 128, 128)
         @ 4.231,3.333 TO 4.231,60.333 ;
            COLOR RGB(255, 255, 255, 255, 255, 255)
         m.g_thermwidth = 56.269
      CASE _MAC
         DEFINE WINDOW thermomete ;
            AT  INT((SROW() - (( 5.62 * ;
            FONTMETRIC(1, m.g_dlgface, m.g_dlgsize, m.g_dlgstyle )) / ;
            FONTMETRIC(1, WFONT(1,""), WFONT( 2,""), WFONT(3,"")))) / 2), ;
            INT((SCOL() - (( 63.83 * ;
            FONTMETRIC(6, m.g_dlgface, m.g_dlgsize, m.g_dlgstyle )) / ;
            FONTMETRIC(6, WFONT(1,""), WFONT( 2,""), WFONT(3,"")))) / 2) ;
            SIZE 5.62,63.83 ;
            FONT m.g_dlgface, m.g_dlgsize ;
            STYLE m.g_dlgstyle ;
            NOFLOAT ;
            NOCLOSE ;
            NONE ;
            COLOR RGB(0, 0, 0, 192, 192, 192)
         MOVE WINDOW thermomete CENTER
         ACTIVATE WINDOW thermomete NOSHOW
         @ 0.000,0.000 TO 5.62,63.83 PATTERN 1;
            COLOR RGB(192, 192, 192, 192, 192, 192)
         IF ISCOLOR()
            @ 0.000,0.000 TO 5.62,63.83 PATTERN 1;
               COLOR RGB(192, 192, 192, 192, 192, 192)
            @ 0.000,0.000 TO 0.000,63.83 ;
               COLOR RGB(255, 255, 255, 255, 255, 255)
            @ 0.000,0.000 TO 5.62,0.000 ;
               COLOR RGB(255, 255, 255, 255, 255, 255)
            @ 0.385,0.67 TO 5.23,0.67 ;
               COLOR RGB(128, 128, 128, 128, 128, 128)
            @ 0.31,0.67 TO 0.31,63.17 ;
               COLOR RGB(128, 128, 128, 128, 128, 128)
            @ 0.385,63.000 TO 5.31,63.000 ;
               COLOR RGB(255, 255, 255, 255, 255, 255)
            @ 5.23,0.67 TO 5.23,63.17 ;
               COLOR RGB(255, 255, 255, 255, 255, 255)
            @ 5.54,0.000 TO 5.54,63.83 ;
               COLOR RGB(128, 128, 128, 128, 128, 128)
            @ 0.000,63.67 TO 5.62,63.67 ;
               COLOR RGB(128, 128, 128, 128, 128, 128)
            @ 3.000,3.33 TO 4.23,3.33 ;
               COLOR RGB(128, 128, 128, 128, 128, 128)
            @ 3.000,60.33 TO 4.31,60.33 ;
               COLOR RGB(255, 255, 255, 255, 255, 255)
            @ 3.000,3.33 TO 3.000,60.33 ;
               COLOR RGB(128, 128, 128, 128, 128, 128)
            @ 4.23,3.33 TO 4.23,60.33 ;
               COLOR RGB(255, 255, 255, 255, 255, 255)
         ELSE
            @ 0.000, 0.000 TO 5.62, 63.830  PEN 2
            @ 0.230, 0.500 TO 5.39, 63.333  PEN 1
         ENDIF
         @ 0.5,3 SAY m.text FONT m.g_dlgface, m.g_dlgsize STYLE m.g_dlgstyle+"T" ;
            COLOR RGB(0,0,0,192,192,192)
         @ 1.5,3 SAY m.prompt FONT m.g_dlgface, m.g_dlgsize STYLE m.g_dlgstyle+"T" ;
            COLOR RGB(0,0,0,192,192,192)

         m.g_thermwidth = 56.27
         IF !ISCOLOR()
            @ 3.000,3.33 TO 4.23, (m.g_thermwidth + 1) + 3.33
         ENDIF
   ENDCASE
   SHOW WINDOW thermomete TOP
ELSE
   m.prompt = SUBSTR(SYS(2014,UPPER(m.g_outfile)),1,48)+;
      IIF(LEN(m.g_outfile)>48,"...","")
   DEFINE WINDOW thermomete;
      FROM INT((SROW()-6)/2), INT((SCOL()-57)/2) ;
      TO INT((SROW()-6)/2) + 6, INT((SCOL()-57)/2) + 57;
      DOUBLE COLOR SCHEME 5
   ACTIVATE WINDOW thermomete NOSHOW
   m.g_thermwidth = 50
   @ 0,3 SAY m.text
   @ 1,3 SAY UPPER(m.prompt)
   @ 2,1 TO 4,m.g_thermwidth+4 &g_boxstrg
   SHOW WINDOW thermomete TOP
ENDIF
RETURN


*
* UPDTHERM(<percent>) - Update thermometer.
*
FUNCTION updtherm
PARAMETER m.percent
PRIVATE m.nblocks, m.percent
ACTIVATE WINDOW thermomete
m.nblocks = (m.percent/100) * (m.g_thermwidth)
DO CASE
   CASE _WINDOWS
      @ 3.000,3.333 TO 4.231,m.nblocks + 3.333 ;
         PATTERN 1 COLOR RGB(128, 128, 128, 128, 128, 128)
   CASE _MAC
      @ 3.000,3.33 TO 4.23,m.nblocks + 3.33 ;
         PATTERN 1 COLOR RGB(0, 0, 128, 0, 0, 128)
   OTHERWISE
      @ 3,3 SAY REPLICATE("█",m.nblocks)
ENDCASE

*
* DEACTTHERMO - Deactivate and Release thermometer window.
*
FUNCTION deactthermo
RELEASE WINDOW thermomete


*
* Function: THERMFNAME
*
* [Rev: 8]
* Modified to use CutFileLoc() if name is too long.
* Moved global variables to top of program.
* Merged thermometer window font info with dialogs.
FUNCTION thermfname
PARAMETER m.fname
IF TXTWIDTH(m.fname,m.g_dlgface,m.g_dlgsize,m.g_dlgstyle) > c_space
   m.fname = CutFileLoc(m.fname, c_space -1)
ENDIF
RETURN PROPER(m.fname)



******************************************************************************
*
* Error Handling Code.
*
******************************************************************************
*
* ERRORHANDLER - Error Processing Center.
*
FUNCTION errorhandler
PARAMETERS m.messg, m.lineno, m.code
IF ERROR() = 22  && Too many memory variables
   =MESSAGEBOX(c_err_toomanymemvars_LOC + REPL(c_CRLF,2) + c_msg_genstopped_LOC)    && Tell the user [Rev: 6][ADD]
   ON ERROR &onerror
   DO cleanup
   CANCEL       && Early exit
ENDIF
DO CASE
   CASE c_DEBUG   && Add debug mode [Rev: 4][BEG]
      =MESSAGEBOX(m.messg)
      SET DEBUG ON
      SET STEP ON
      * Add debug mode [Rev: 4][END]
   CASE m.code == c_error_1  && Minor
      DO errlog WITH m.messg, m.lineno
      DO errshow WITH m.messg, m.lineno, c_error_1Icon   && Show minor errors [Rev: 6][ADD]
      m.g_status = 1
   CASE m.code == c_error_2  && Serious
      DO errlog  WITH m.messg, m.lineno
      DO errshow WITH m.messg, m.lineno, c_error_2Icon   && Pass Error Icon [Rev: 6][ADD]
      m.g_error = .T.
      m.g_status = 2
      ON ERROR
   CASE m.code == c_error_3  && Fatal
      IF NOT m.g_nohandle
         DO errlog  WITH m.messg, m.lineno
      ENDIF
      WAIT WINDOW c_msg_genstopped_LOC NOWAIT   && Tell the user they are done. [Rev: 6][ADD]
      DO errshow WITH m.messg, m.lineno, c_error_3Icon   && Pass Error Icon [Rev: 6][ADD]
      WAIT CLEAR
      IF WEXIST("Thermomete") AND WVISIBLE("Thermomete")
         RELEASE WINDOW thermomete
      ENDIF
      ON ERROR
      DO cleanup
      CANCEL      && Early exit
ENDCASE
RETURN


*
* ESCHANDLER - Escape handler.
*
FUNCTION eschandler
ON ERROR
WAIT WINDOW c_msg_genstopped_LOC NOWAIT   && Localization support [Rev: 2][MOD]
DO builddisable
IF m.g_status > 0
   ERASE (m.g_outfile)
ENDIF
IF WEXIST("Thermomete") AND WVISIBLE("Thermomete")
   RELEASE WINDOW thermomete
ENDIF
DO cleanup
CANCEL      && Early exit


*
* ERRLOG - Insert error message into the error log.
*
FUNCTION errlog
PARAMETER m.messg, m.lineno
PRIVATE m.savehandle
m.savehandle = _TEXT
DO openerrfile
SET CONSOLE OFF

\\GENERATOR: <<ALLTRIM(m.messg)>>
IF NOT EMPTY(m.lineno)
   \\ LINE NUMBER: <<m.lineno>>
ENDIF
\
= FCLOSE(_TEXT)
_TEXT = m.savehandle
RETURN


*
* ERRSHOW - Display error message in the alert box.
*
FUNCTION errshow
PARAMETER m.msg, m.lineno, m.msgicon
PRIVATE m.curcursor
* Modify to utilize native MESSAGEBOX() function. [Rev: 6][BEG]
IF m.g_graphic
   m.msg = m.msg + REPL(c_CRLF,2) + ;
           c_err_lineno_LOC + STR(m.lineno, 4)
   =MESSAGEBOX(m.msg, m.msgicon, c_err_title_LOC)
ELSE
   DEFINE WINDOW alert;
      FROM INT((SROW()-6)/2), INT((SCOL()-50)/2) TO INT((SROW()-6)/2) + 6, INT((SCOL()-50)/2) + 50 ;
      FLOAT NOGROW NOCLOSE NOZOOM    SHADOW DOUBLE;
      COLOR SCHEME 7

   ACTIVATE WINDOW alert
   @ 0,0 CLEAR
   @ 1,0 SAY PADC(SUBSTR(m.msg,1,44)+;
      IIF(LEN(m.msg)>44,"...",""), WCOLS())
   @ 2,0 SAY PADC(c_err_lineno_LOC + STR(m.lineno, 4), WCOLS())   && Localization support [Rev: 2][MOD]
   @ 3,0 SAY PADC(c_err_presskey_LOC, WCOLS())   && Localization support [Rev: 2][MOD]
   m.curcursor = SET( "CURSOR" )
   SET CURSOR OFF
   WAIT ""
   RELEASE WINDOW alert
   SET CURSOR &curcursor
   RELEASE WINDOW alert
ENDIF
* Modify to utilize native MESSAGEBOX() function. [Rev: 6][END]
RETURN



*
* OPENERRFILE - Open error file.
*
FUNCTION openerrfile
PRIVATE m.errfile, m.errhandle
m.errfile   = m.g_errlog+".ERR"
m.errhandle = FOPEN(m.errfile,2)
IF m.errhandle < 0
   m.errhandle = FCREATE(m.errfile)
   IF m.errhandle < 0
      DO errshow WITH c_err_noopenerr_LOC, LINENO()   && Localization support [Rev: 2][MOD]
      m.g_status = 2
      IF WEXIST("Thermomete") AND WVISIBLE("Thermomete")
         RELEASE WINDOW thermomete
      ENDIF
      ON ERROR
      RETURN TO MASTER
   ENDIF
ELSE
   = FSEEK(m.errhandle,0,2)
ENDIF
IF SET("TEXTMERGE") = "OFF"
   SET TEXTMERGE ON
ENDIF
_TEXT = m.errhandle



*
* GETCNAME - Manufacture a procedure name, unless there is a #NAME directive
*
FUNCTION getcname
PARAMETERS snippet
PRIVATE ALL
IF proctype = 1
   numlines = MEMLINES(snippet)
   IF m.numlines > 0
      _MLINE = 0
      m.i = 1
      DO WHILE m.i <= m.numlines
         m.thisline = UPPER(ALLTRIM(MLINE(snippet,1, _MLINE)))
         DO CASE
        CASE LEFT(m.thisline,5) == "#NAME"
               RETURN ALLTRIM(SUBSTR(m.thisline,6))
            CASE EMPTY(m.thisline) OR iscomment(m.thisline)
               * Do nothing.  Get next line.
            OTHERWISE
               EXIT
         ENDCASE
         m.i = m.i + 1
      ENDDO
   ENDIF
ENDIF
RETURN LOWER(SYS(2015))


*
* ISCOMMENT - Determine if textline is a comment line.
*
FUNCTION IsComment
PARAMETER m.textline
PRIVATE m.asterisk, m.isnote, m.ampersand, m.statement
IF EMPTY(m.textline)
   RETURN .F.
ENDIF
m.statement = UPPER(ALLTRIM(m.textline))

m.asterisk  = AT("*", LEFT(m.statement,1))
m.ampersand = AT(CHR(38)+CHR(38), LEFT(m.statement,2))
m.isnote    = AT("NOTE", LEFT(m.statement,4))
DO CASE
   CASE (m.asterisk = 1 OR m.ampersand = 1)
      RETURN .T.
   CASE (m.isnote = 1 ;
         AND (LEN(m.statement) <= 4 OR SUBSTR(m.statement,5,1) = ' '))
      * Don't be fooled by something like "notebook = 7"
      RETURN .T.
ENDCASE
RETURN .F.


*
* WORDNUM - Returns w_num-th word from string strg
*
FUNCTION wordnum
PARAMETERS strg,w_num
PRIVATE strg,s1,w_num,ret_str
m.s1 = ALLTRIM(m.strg)
* Replace tabs with spaces
m.s1 = CHRTRAN(m.s1,CHR(9)," ")
* Reduce multiple spaces to a single space
DO WHILE AT('  ',m.s1) > 0
   m.s1 = STRTRAN(m.s1,'  ',' ')
ENDDO
ret_str = ""
DO CASE
   CASE m.w_num > 1
      DO CASE
         CASE AT(" ",m.s1,m.w_num-1) = 0   && No word w_num.  Past end of string.
            m.ret_str = ""
         CASE AT(" ",m.s1,m.w_num) = 0     && Word w_num is last word in string.
            m.ret_str = SUBSTR(m.s1,AT(" ",m.s1,m.w_num-1)+1,255)
         OTHERWISE                         && Word w_num is in the middle.
            m.strt_pos = AT(" ",m.s1,m.w_num-1)
            m.ret_str  = SUBSTR(m.s1,strt_pos,AT(" ",m.s1,m.w_num)+1 - strt_pos)
      ENDCASE
   CASE m.w_num = 1
      IF AT(" ",m.s1) > 0               && Get first word.
         m.ret_str = SUBSTR(m.s1,1,AT(" ",m.s1)-1)
      ELSE                              && There is only one word.  Get it.
         m.ret_str = m.s1
      ENDIF
ENDCASE
RETURN ALLTRIM(m.ret_str)


*
* VERSNUM - Return string corresponding to FoxPro version number
*
FUNCTION versnum
RETURN STRTRAN(SUBS(VERS(),AT(".",VERS())-2),"0","",1,1)

PROCEDURE sdiheader
\* To attach this menu to your Top-Level form,
\* call it from the Init event of the form:
\
\* Syntax: DO <mprname> WITH <oFormRef> [,<cMenuname>|<lRename>][<lUniquePopups>]
\
\*    oFormRef - form object reference (THIS)
\*    cMenuname - name for menu (this is required for Append menus - see below)
\*    lRename - renames Name property of your form
\*    lUniquePopups - determines whether to generate unique ids for popup names
\
\*     example:
\
\*    PROCEDURE Init
\*        DO mymenu.mpr WITH THIS,.T.
\*    ENDPROC
\
\* Use the optional 2nd parameter if you plan on running multiple instances
\* of your Top-Level form. The preferred method is to create an empty string
\* variable and pass it by reference so you can receive the form name after
\* the MPR file is run. You can later use this reference to destroy the menu.
\
\*    PROCEDURE Init
\*        LOCAL cGetMenuName
\*        cGetMenuName = ""
\*        DO mymenu.mpr WITH THIS, m.cGetMenuName
\*    ENDPROC
\
\* The logical lRename parameter will change the name property of your
\* form to the same name given the menu and may cause conflicts in your
\* code if you directly reference the form by name.
\
\* You will also need to remove the menu when the form is destroyed so that it does
\* not remain in memory unless you wish to reactivate it later in a new form.
\
\* If you passed the optional lRename parameter as .T. as in the above example,
\* you can easily remove the menu in the form's Destroy event as shown below.
\* This strategy is ideal when using multiple instances of Top-Level forms.
\
\*    example:
\
\*    PROCEDURE Destroy
\*        RELEASE MENU (THIS.Name) EXTENDED
\*    ENDPROC
\
\* Using Append/Before/After location options:
\
\*   You might want to append a menu to an existing Top-Level form by setting
\*   the Location option in the General Options dialog. In order to do this, you
\*   must pass the name of the menu in which to attach the new one. The second
\*   parameter is required here. If you originally created the menu with the lRename
\*   parameter = .T., then you can update the menu with code similar to the following:
\
\*    example:
\
\*    DO mymenu2.mpr WITH THISFORM,THISFORM.name
\*
\* Using lUniquePopups:
\
\*   If you are running this menu multiple times in your application, such as in multiple
\*   instances of the same top-level form, you should pass .T. to the lUniquePopups
\*   parameter so that unique popup names are generated to avoid possible conflicts.
\
\*    example:
\
\*    PROCEDURE Init
\*        DO mymenu.mpr WITH THIS,.T.,.T.
\*    ENDPROC
\*
\* Note: Parm4-Parm9 are not reserved and freely available for use with your menu code.
\*
\
\LPARAMETERS oFormRef, getMenuName, lUniquePopups, parm4, parm5, parm6, parm7, parm8, parm9
\LOCAL cMenuName, nTotPops, a_menupops, cTypeParm2, cSaveFormName
\IF TYPE("m.oFormRef") # "O" OR ;
\  LOWER(m.oFormRef.BaseClass) # 'form' OR ;
\  m.oFormRef.ShowWindow # 2
\    MESSAGEBOX(<<c_sdierrdisplay_loc>>)
\    RETURN
\ENDIF

\m.cTypeParm2 = TYPE("m.getMenuName")
\m.cMenuName = SYS(2015)
\m.cSaveFormName = m.oFormRef.Name

*!*    \DO CASE
*!*    \CASE m.cTypeParm2 = "C" AND !EMPTY(m.getMenuName)
*!*    \    m.cMenuName = m.getMenuName
*!*    \CASE m.cTypeParm2 = "C" OR (m.cTypeParm2 = "L" AND m.getMenuName)
*!*    \    m.oFormRef.Name = m.cMenuName
*!*    \ENDCASE

\IF m.cTypeParm2 = "C" OR (m.cTypeParm2 = "L" AND m.getMenuName)
\    m.oFormRef.Name = m.cMenuName
\ENDIF
\IF m.cTypeParm2 = "C" AND !EMPTY(m.getMenuName)
\    m.cMenuName = m.getMenuName
\ENDIF

LOCAL ntotpops,cPopRef ,i
SELECT PADR(LOWER(name),25) FROM (DBF());
    WHERE numitems#0 AND objtype =2 AND ATC("_MSYSMENU",levelname)=0;
    INTO ARRAY g_aPops
m.ntotpops=_TALLY
IF m.ntotpops>0
    DIMENSION g_aPops[m.ntotpops]
    \DIMENSION a_menupops[<<m.ntotpops>>]
    \IF TYPE("m.lUniquePopups")="L" AND m.lUniquePopups
    \    FOR nTotPops = 1 TO ALEN(a_menupops)
    \        a_menupops[m.nTotPops]= SYS(2015)
    \    ENDFOR
    \ELSE
    FOR i = 1 TO ALEN(g_aPops)
        g_aPops[m.i] = ALLTRIM(g_aPops[m.i])
        \    a_menupops[<<m.i>>]="<<LOWER(g_aPops[m.i])>>"
    ENDFOR
    \ENDIF
    \
ENDIF
ENDFUNC


* GetMenuType
* Description: Determines which type of menu we have.
* Parameters:
* Return value:
*
PROCEDURE GetMenuType
* Determine if we have a shortcut menu
LOCATE FOR objtype = c_shortcut
IF FOUND()
    m.g_shortcut   = .T.
    RETURN
ENDIF

* Determine if we have SDI menu
LOCATE FOR objtype = c_sdimenu
IF FOUND()
    m.g_inform     = .T.
ENDIF
RETURN

* actpopup
* Description: writes out code to
* activate popup if we have shortcut menu
* Parameters:
* Return value:
*
PROCEDURE actpopup
DO CASE
CASE m.g_shortcut
    \ACTIVATE POPUP <<m.g_shortcutname>>
CASE m.g_inform AND m.g_location = c_replace
    \ACTIVATE MENU (m.cMenuName) NOWAIT
CASE m.g_inform
    \ACTIVATE MENU (m.cMenuName) NOWAIT
ENDCASE
IF m.g_inform
    \
    \IF m.cTypeParm2 = "C"
    \    m.getMenuName = m.cMenuName
    \    m.oFormRef.Name = m.cSaveFormName
    \ENDIF
    \
ENDIF
RETURN


******************************************************************************
*
*  File and Path functions
*
******************************************************************************
*
* CUTFILELOC - Return a chopped file and path
*
*
FUNCTION cutfileloc
LPARAMETERS cFile, nLength
LOCAL cString, cTempPath, cTempFile, nPlen, nFlen
IF LEN(m.cFile) > m.nLength
   * Get everything uppercase
   cFile = UPPER(m.cFile)
   * Get the filename and length
   cTempFile = justfname(m.cFile)
   nFlen = LEN(m.cTempFile)
   * Find the minimum path length (could be "c:\")
   cTempPath = cutfpath(STRTRAN(m.cFile,m.cTempFile,"",1),8)
   nPlen = LEN(m.cTempPath)
   * If the filename + the min path is longer than nLength, cut the file name.
   IF m.nFlen + m.nPlen > m.nLength
      cString = m.cTempPath + cutfname(m.cFile,m.nLength-m.nPlen)
   ELSE
      cTempPath = STRTRAN(m.cFile,m.cTempfile,"",1)
      cString = cutfpath(m.cTempPath,(m.nLength-m.nFlen)) + m.cTempfile
   ENDIF
ELSE
   cString = m.cFile
ENDIF
RETURN m.cString



*
* Function: PARTIALFNAME
*
FUNCTION partialfname
PARAMETER m.filname, m.fillen
* Return a filname no longer than m.fillen characters.  Take some chars
* out of the middle if necessary.  No matter what m.fillen is, this function
* always returns at least the file stem and extension.
PRIVATE m.bname, m.elipse, m.remain
m.elipse = "..." + m.g_pathsep
IF _MAC
    m.bname = SUBSTR(m.filname, RAT(":",m.filname)+1)
ELSE
    m.bname = justfname(m.filname)
ENDIF
DO CASE
CASE LEN(m.filname) <= m.fillen
   m.retstr = m.filname
CASE LEN(m.bname) + LEN(m.elipse) >= m.fillen
   m.retstr = m.bname
OTHERWISE
   m.remain = MAX(m.fillen - LEN(m.bname) - LEN(m.elipse), 0)
   IF _MAC
       m.retstr = LEFT(SUBSTR(m.filname,1,RAT(":",m.filname)-1),m.remain) ;
            +m.elipse+m.bname
   ELSE
         m.retstr = LEFT(justpath(m.filname),m.remain)+m.elipse+m.bname
   ENDIF
ENDCASE
RETURN m.retstr



*
* CUTFNAME - Return a chopped filename
*
*  ie: "REALLYLONGFILENAME.TXT" = "REALLYLONG..."
FUNCTION cutfname
LPARAMETERS cFilename, nLength
cFilename = ALLTRIM(m.cFilename)
IF RAT(m.g_pathsep,m.cFilename) > 0
   m.cFilename = SUBSTR(m.cFilename,RAT(m.g_pathsep,m.cFilename)+1)
ENDIF
IF LEN(m.cFilename) > m.nLength
   m.cFilename = LEFT(m.cFilename,m.nLength-4) + "..."
ENDIF
RETURN m.cFilename



*
* CUTFPATH - Return a chopped filepath
*
*  ie: "C:\REALLYLONGPATH\SUB\ETC\" = "C:\ ...\SUB\ETC\"
FUNCTION cutfpath
LPARAMETERS cFilepath, nLength
LOCAL cPre, cString, nRemain, nOccurs
IF _MAC OR LEN(m.cFilepath) > m.nLength
   cFilePath = SYS(2027, m.cFilePath)  && Remove relative paths
ENDIF
IF LEN(m.cFilepath) > m.nLength
   cPre = LEFT(m.cFilePath,AT(m.g_pathsep,m.cFilePath)) + "... " + m.g_pathsep
   nRemain = nLength - LEN(m.cPre)
   cString = RIGHT(cFilepath,m.nRemain)
   IF OCCURS(m.g_pathsep,m.cString)>1
      cString = m.cPre + SUBS(cString,AT(m.g_pathsep,m.cString))
   ELSE
      cString = m.cPre  && last directory on path is too long
   ENDIF
ELSE
   cString = m.cFilepath
ENDIF
RETURN m.cString



*
* JUSTFNAME - Return just a filename
*
FUNCTION justfname
PARAMETERS m.filname
PRIVATE ALL
IF RAT('\',m.filname) > 0
   m.filname = SUBSTR(m.filname,RAT('\',m.filname)+1,255)
ENDIF
IF AT(':',m.filname) > 0
   m.filname = SUBSTR(m.filname,AT(':',m.filname)+1,255)
ENDIF
RETURN ALLTRIM(UPPER(m.filname))


*
* JUSTPATH - Return just the path name from "filname"
*
FUNCTION justpath
PARAMETERS m.filname
PRIVATE ALL
m.filname = ALLTRIM(UPPER(m.filname))
IF '\' $ m.filname
   m.filname = SUBSTR(m.filname,1,RAT('\',m.filname))
   IF RIGHT(m.filname,1) = '\' AND LEN(m.filname) > 1 ;
         AND SUBSTR(m.filname,LEN(m.filname)-1,1) <> ':'
      filname = SUBSTR(m.filname,1,LEN(m.filname)-1)
   ENDIF
   RETURN m.filname
ELSE
   RETURN ''
ENDIF


*
* STRIPEXT - Strip the extension from a file name.
*
* Description:
* Use the algorithm employed by FoxPRO itself to strip a
* file of an extension (if any): Find the rightmost dot in
* the filename.  If this dot occurs to the right of a "\"
* or ":", then treat everything from the dot rightward
* as an extension.  Of course, if we found no dot,
* we just hand back the filename unchanged.
*
* Parameters:
* filename - character string representing a file name
*
* Return value:
* The string "filename" with any extension removed
*
FUNCTION stripext
PARAMETER m.filename
PRIVATE m.dotpos, m.terminator
m.dotpos = RAT(".", m.filename)
m.terminator = MAX(RAT("\", m.filename), RAT(":", m.filename))
IF m.dotpos > m.terminator
   m.filename = LEFT(m.filename, m.dotpos-1)
ENDIF
RETURN m.filename


*
* STRIPPATH - Strip the path from a file name.
*
* Description:
* Find positions of backslash in the name of the file.  If there is one
* take everything to the right of its position and make it the new file
* name.  If there is no slash look for colon.  Again if found, take
* everything to the right of it as the new name.  If neither slash
* nor colon are found then return the name unchanged.
*
* Parameters:
* filename - character string representing a file name
*
* Return value:
* The string "filename" with any path removed
*
FUNCTION strippath
PARAMETER m.filename
PRIVATE m.slashpos, m.namelen, m.colonpos
m.slashpos = RAT("\", m.filename)
IF m.slashpos > 0
   m.namelen  = LEN(m.filename) - m.slashpos
   m.filename = RIGHT(m.filename, m.namelen)
ELSE
   m.colonpos = RAT(":", m.filename)
   IF m.colonpos > 0
      m.namelen  = LEN(m.filename) - m.colonpos
      m.filename = RIGHT(m.filename, m.namelen)
   ENDIF
ENDIF
RETURN m.filename


* BASENAME - returns strippath(stripext(filespec))
*
FUNCTION basename
PARAMETER m.filespec
RETURN strippath(stripext(m.filespec))



******************************************************************************
* Revisions History
* $History: GENMENU.PRG $
 *
 * *****************  Version 11  *****************
 * User: rb          Date: 11/30/96    Time: 1:04a
 * Updated in $/Genmenu
 * Enhanced #PREPOP for Cleanup snippet placeholder
 * Changed naming convention of menu popups in Top-Level
 *    form menus to avoid conflicts with RELEASE MENU...
 *    extended.
 * Fixed Top-Level Form - append menu problem.
 * Fixed Setup/Cleanup code not gen for Top-Level Form.
 * *****************  Version 10  *****************
 * User: rb          Date: 5/1/96    Time: 1:04a
 * Updated in $/Genmenu
 * Added #PREPOPUP generator directive to control whether
 * Cleanup code is placed before/after ACTIVATE POPUP
 * line for Shortcut menus.
 * *****************  Version 9  *****************
 * User: rb          Date: 3/8/96    Time: 1:04a
 * Updated in $/Genmenu
 * Added support for new shortcut popup and SDI form menus
 * - actpopup() new proc to add shortcut activate code
 * - GetMenuType() new proc to determine menu type (shortcut, SDI, etc.)
 * - defbars () added new parameter to safeguard shortcut popup name
 * - defonbar () added new parameter to safeguard shortcut popup name
 * *****************  Version 8  *****************
 * User: Dta          Date: 3/19/95    Time: 1:04a
 * Updated in $/Genmenu
 * - Thermfname() modified to use new function CutFileLoc().
 * - CutFileLoc(), CutFPath() and CutFName() written to handle
 *   formating for long file, path and directory names.
 * - Grouped similiar functions.
 * - Fixed release thermometer window bug.
 * - Merge dialog and thermometer fonts.
 * - Moved g_pathsep to globals definition area.
 *
 * *****************  Version 7  *****************
 * User: Dta          Date: 3/18/95    Time: 7:36p
 * Updated in $/Genmenu
 * - Change c_aliaslen to 255 to support long file names.
 * - Add support for intelligent Pad hotkeys
 *
 * *****************  Version 6  *****************
 * User: Dta          Date: 3/18/95    Time: 5:19p
 * Updated in $/Genmenu
 * - Add support for no "!" in menu file name.
 * - Modify error routine to utilize MESSAGEBOX()
 *
 * *****************  Version 5  *****************
 * User: Dta          Date: 1/11/95    Time: 9:45a
 * Updated in $/Genmenu
 * - Beautified and documentation changes
 * - Branched for Localization
 *
 * *****************  Version 4  *****************
 * User: Dta          Date: 1/10/95    Time: 6:36p
 * Updated in $/Genmenu
 * - Add support for DEBUG mode
 * - Add message for ERROR 22
 * - #DEFINEs moved above executable code
 * - Dialog Fonts changed for localization
 *
 * *****************  Version 3  *****************
 * User: Dta          Date: 1/10/95    Time: 5:56p
 * Updated in $/Genmenu
 * - Change localization constants to support naming convention.
 *
 * *****************  Version 2  *****************
 * User: Dta          Date: 12/10/94    Time: 8:20a
 * Updated in $/Genmenu
 * - Change PJXFields constant to 3.0 value.
 * - Add AGAIN to USE command when opening project.
 * - Add constants for Localization support.
 * - Remove "arranged" from NOCPTRANS command.
 * - Modify VERSNUM() to support 3.0 VERS() convention.
 * - Add version control documentation.
 *
 * *****************  Version 1  *****************
 * User: Dta          Date: 12/1/95    Time: 3:13p
 * Added in $/Genmenu
 * - Orignial 2.6a GENMENU shipping version.
 *
*